***
***
*** This Program already converted to Y2K
*** S&T Departement     on 29 April 1999 by Ben.Rahman
***
***
set cent on
*  FILE NAME: LABT.PRG
*  BY: LIOE TIAK FA
*  DATE: December 4, 1995
*  DESC:
*  CALLED BY:
*  DATA FILES:
SET COLO TO BG+/B
CLEAR
SET PROC TO SOSPRO1
SET PROC TO BOXPROC
SET PROC TO LABPROC
STORE ' ' TO AEANAME,AEAADDR,AEACITY,AEACOUN,AEACURR,AEASTNM
STORE .F. TO AEAHEAL,AEADECI,AEASITE
DO START
REST FROM  N:VISLAB addi
PUBLIC VISLA
DR="N:"
DOI=DATE()
store 0 to SWW,sww1,sww2,sww3,cr1,cnt1,CNT2,PL1,PL2,PL3,PL4,PL5,PL6,PL7,PL8,PL9,PL10,pl11,pl12,PL13,PL14,PL15,PL16,PL17,PL18
STORE .F. TO PATIN,FRUSEL,COMPLT,termin,patid
TGLL=SUBSTR(DTOC(DOI),1,2)
DO WHILE .NOT. PATIN .AND. SWW<3 .AND. LASTKEY()<>27
   SET COLOR TO BG+/B
   @ 0,0 CLEA TO 24,79
   STORE 0 TO TOTL,NPROC,TOTPAY,TOTHL,TOTFEE,TOTPROC,NORE,DQNT,PTOTL,PILC,MTOTL
   STORE SPACE(6) TO KDPAT,KODE
   STORE SPACE(1) TO TPPAT,CRPAT,MNMPAT,ISEX
   STORE SPACE(4) TO DTPAT, COPAT
   STORE SPACE(8) TO MDSNBR
   STORE SPACE(16) TO NMPAT,FNMPAT,NATIO,DEPPER
   STORE CTOD('  /  /    ') TO DOBPAT,HLBEGIN,MDSDAT
   STORE .F. TO HEALTH, HLRES, HLVOID,PERSO,FAMIL,MDS,PREND
   HLDATE=DATE()
   F1='IN_PAT'
   f2='LABORAT'
   SELE 1
   SET EXCLU OFF
   USE &DR&F1
   DO ADDRESSC
   DO BOXT WITH 3,17,'LABORATORY REGISTRATION','W+','B',.F.,.T.
   SET COLO TO BG+/B
   @ 6, 3 SAY "SURNAME :"
   @ 6,30 SAY "FIRST NAME :"
   @ 6,60 SAY "MID.INITIAL :"
   @ 7, 3 SAY "DATE OF BIRTH :"
   @ 7,29 SAY "NATIONALITY :"
   @ 7,62 SAY "SEX (M/F) :"
   DO BOXE WITH 3,45,'PATIENT CODE :','KODE','GR+','R','N','W+',6,.F.,.T.
   SET COLO TO BG+/B,W+/N
   SELE 1
   LOCA FOR PAT_FILCOD=KODE
   IF .NOT. FOUND()
      SWW=SWW+1
      SET COLO TO BG+/B*
      set cons off
      DO BOXF WITH 14,17,'>>>>> WRONG CODE, PLEASE ENTER AGAIN <<<<<','GR+','R','GR+*',.T.,.T.
      WAIT ' '
      set cons on
      SET COLO TO BG+/B
      @ 14,17 CLEA TO 23,78
   ELSE
      PATID=.T.
   ENDIF
   IF PATID
      DO CASHDPAT
      DO BOX2 WITH 20,20,'DO YOU WANT TO :','CONFIRM','CANCEL','W+','B','GR+','N',PL1,.T.,.T.
      IF PL1=1
         PATIN=.T.
      ENDIF
   ENDIF
ENDDO
IF .NOT. PATIN
   RETURN
ENDIF

nore=recno()
fill='\temp\la'+kdpat+'.dbf'
film='\temp\ME'+kdpat+'.dbf'
filp='\temp\PH'+kdpat+'.dbf'
F4='MEDIC_PR'
f7='sub_areL'
f6="\temp\la"+kdpat

use &dr&f2
copy stru to &dr&f6
sele 6
use &dr&f6

SET COLOR TO BG+/B
@ 11,0 CLEAR to 24,79
VISLA=VISLA+1
NOBER=STR(VISLA,5)
STORE 0 TO TOTL,LABCNT
STOR SPAC(4) TO KODEP
STESC = ' '
DO WHILE .NOT. TERMIN
   DO WHILE .NOT. COMPLT .AND. .NOT. TERMIN
      STORE .F. TO MRES,HRES
      STORE 0 TO PLAB,MLAB,HLAB,COSTAL,NUMB,pub
      set color to bg+/b
      @ 9,0 clea to 18,45
      @ 19,0 CLEA TO 24,79
      DO BOXT WITH 22,46,'TOTAL PAYABLE (Rp.) :'+TRANS(TOTL,'#,###,###'),'GR+','B',.F.,.T.
      sele 6
      use &dr&f6
      SELE 4
      SET EXCLU OFF
      USE &DR&F4 INDEX &DR&F4
      SELE 7
      SET EXCLU OFF
      USE &DR&F7
      KODEP  = SPAC(4)
      SVLABT = SAVESCREEN(00,00,24,80)
      DO BOXLAB WITH 10,26,'LABORATORY TEST CODE :','KODEP','GR+','R','N','W+',4,.F.,.T.
      IF KODEP =SPAC(4) .OR. LASTKEY() = 27
         STESC = 'N'
         PL2 = 2
         do box2 with 22,0,'DO YOU WANT TO :','ESCAPE','CONTINUE','GR+','R','GR+','N',PL2,.F.,.T.
         IF PL2=1
            STESC='Y'
            RETURN
         ENDIF
         EXIT
      ENDI
      KODEP   = ALLTRIM(KODEP)
      nLkodep = LEN(KODEP)
      SELE 4
      SEEK KODEP
      IF SUBS(KODEP,1,1)='L' .AND. .NOT. EOF()
         IF nLkodep < 4
            CNT = 0
            cArcod = ALLTRIM(AREA_CODE)+ALLTRIM(SUB_AREACO)+ALLTRIM(PRO_CODE)
            DO WHIL (KODEP = SUBS(cArcod,1,nLkodep)) .AND. .NOT. EOF()
               CNT = CNT + 1
               SKIP
               cArcod = ALLTRIM(AREA_CODE)+ALLTRIM(SUB_AREACO)+ALLTRIM(PRO_CODE)
            ENDD
            CNT2 = CNT
            DECLARE aRec[CNT]
            DECLARE aArec[CNT]
            DECLARE aSubc[CNT]
            DECLARE aProc[CNT]
            DECLARE aSDes[CNT]
            DECLARE ASUN[CNT]
            DECLARE FILD[CNT]
            CNT  = 0
            GO TOP
            SEEK KODEP
            cArcod = ALLTRIM(AREA_CODE)+ALLTRIM(SUB_AREACO)+ALLTRIM(PRO_CODE)
            DO WHIL (KODEP = SUBS(cArcod,1,nLkodep)) .AND. .NOT. EOF()
               CNT = CNT + 1
               aRec[CNT]   = RECNO()
               aArec[CNT]  = AREA_CODE
               aSubc[CNT]  = SUB_AREACO
               aProc[CNT]  = PRO_CODE
               aSdes[CNT]  = SHRT_DESCR
               ASUN[CNT]   = SUN_PC
               FILD[CNT]   = AREA_CODE+SUB_AREACO+PRO_CODE+'   '+substr(sub_area,1,12)+'  '+SHRT_DESCR
               SKIP
               cArcod = ALLTRIM(AREA_CODE)+ALLTRIM(SUB_AREACO)+ALLTRIM(PRO_CODE)
            ENDD

            CNT = 1
            GO aRec[CNT]

            BRS = 20
            IF CNT2 < 10
               BRS = 10 + CNT2
            ENDI
            BRS2 = BRS - 1
            SET COLO TO B/B
            @09,25 CLEA TO 15,79
            @09,25 CLEA TO BRS,79
            SET COLO TO GR+/R,GR+/R
            @09,25 TO BRS,79 DOUBLE
            SET COLO TO W+/R,W+/BG
            STESC = ' '
            DO WHIL .T.
               nPil = achoice(10,26,BRS2,78,FILD)
               IF LASTKEY() = 27
                  STESC = 'Y'
                  EXIT
               ELSE
                  IF LASTKEY() = 13
                     nRec  = aRec[nPil]
                     cArec = aArec[nPil]
                     cSubc = aSubc[nPil]
                     cProc = aProc[nPil]
                     cSdes = aSdes[nPil]
                     SUNPC = ASUN[NPIL]
                     GO nRec
                     EXIT
                  ENDI
                  STESC = 'T'
               ENDI
            ENDD
            RESTSCREEN(00,00,24,80,SVLABT)
            IF STESC = 'Y'
               STESC = ' '
               CLOS DATA
               if LASTKEY() = 0
                  LOOP
	       endif  
            ENDI
         ENDI
      ELSE
         RESTSCREEN(00,00,24,80,SVLABT)
         STESC = ' '
         CLOS DATA
         LOOP
      ENDI
      RESTSCREEN(00,00,24,80,SVLABT)
      KODEP = AREA_CODE+SUB_AREACO+PRO_CODE
      SUNPC = SUN_PC
      HELT=HEALTHLINE
      med=MED_S
      TARIM=TARIF_METH

      SARE=SUB_AREA
      DSCR=SHRT_DESCR

      PUB = PUB_PRICE      
      SET COLOR TO BG+/B
      @ 9,0 CLEA TO 21,45
      do boxt with 9,0,ALLTRIM(sare)+', '+ALLTRIM(dscr),'w+','g',.F.,.T.
      DO BOXT WITH 12,0,'UNIT PRICE (Rp.) :'+TRANS(pUB,'#,###,###'),'w+','r',.F.,.T.
      do boxn with 15,0,'Number of '+tarim+' :','numb','99','BG+','B','W+','N','99','0',.F.,.F.
      PRIC=PUB
      LABCNT=LABCNT+1

      plc=1
      CIT=.F.
      *****   do box2 with 19,0,'CITO :','YES','NO','gr+','r','W+','N',PLC,.F.,.t.
      PUB=PRIC
      PRIC=PRIC*NUMB
      DO BOXT WITH 19,46,'PAYABLE PRICE (Rp.) :'+TRANS(pRIC,'#,###,###'),'GR+','B',.F.,.T.
      do box2 with 22,0,'Do You Want To :','CONFIRM','MODIFY','gr+','r','W+','N',PL3,.F.,.t.
      IF PL3=2 .OR. LASTKEY()=27
         RESTSCREEN(00,00,24,80,SVLABT)
         LOOP
      Endif

      TOTL=TOTL+PRIC
*      TOTL=TOTL+Plab
      set color to bg+/b
      @ 9,0 clea to 24,79
      DO BOXT WITH 22,46,'TOTAL PAYABLE (Rp.) :'+TRANS(TOTL,'#,###,###'),'GR+','B',.F.,.T.
      SELE 6
      IF FIL_LOCK(0)
         APPEN BLANK
      ENDIF
      IF REC_LOCK(0)
         REPL PAT_FILCOD WITH KDPAT,PAT_CODTYP WITH TPPAT,PAT_NAME WITH NMPAT, PAT_F_NAME WITH FNMPAT
         REPL PAT_M_INIT WITH MNMPAT,DATE_VISIT WITH DATE(),VISIT_NBER WITH NOBER,PROC_HL WITH HLAB,PROC_MS WITH MLAB
         REPL AREA_CODE WITH 'L',SUB_AREACO WITH SUBSTR(KODEP,2,1),PRO_CODE WITH SUBS(KODEP,3,2)
         REPL SHRT_DESCR WITH DSCR, PROC_X WITH NUMB,PUB_PRICE WITH PUB,HEALTHLINE WITH HRES,MED_SCHM WITH MRES
         REPL MAIN_AREA WITH 'LABORATORY',PROC_NBER WITH STR(LABCNT,2),TOT_PRICE WITH PRIC
*	 REPL PROC_PAY WITH PLAB
	 REPL PROC_PAY WITH PRIC
         REPL LABT_CITO WITH CIT,SUN_PC WITH SUNPC
      ENDIF
      UNLOCK
      DO LABLIST
      do box2 with 22,0,'ENTER OTHER TEST :','YES','NO','gr+','r','W+','N',PL4,.F.,.t.
      IF PL4=2
         COMPLT=.T.
      ENDIF
      RESTSCREEN(00,00,24,80,SVLABT)
      set color to bg+/b
      @ 9,0 clea to 24,79
      DO BOXT WITH 22,46,'TOTAL PAYABLE (Rp.) :'+TRANS(TOTL,'#,###,###'),'GR+','B',.F.,.T.
   ENDDO
   IF STESC = 'Y'
      EXIT
   ENDI
   STORE .F. TO LDE,ODEL
   set color to bg+/b
   @ 9,0 clea to 21,79
   @ 22,0 clea to 24,45
   DO BOXF WITH 9,0,"REVIEW TEST ENTRY. Type 'Esc' if correct, 'Enter' To Delete one item",'GR+','R','GR+*',.F.,.T.
   DO WHILE .NOT. ODEL
      STORE 0 TO CNT,CR
      SELE 6
      GO TOP
      count to cnt FOR VISIT_NBER=STR(VISLA,5)
      IF CNT=0
         EXIT
      ENDIF

      declare medc[cnt]
      declare fil1[cnt]
      DECLARE REC[CNT]
      DECLARE PR[CNT]
      go top
      DO WHILE .NOT. EOF()
         IF VISIT_NBER<>STR(VISLA,5)
            SKIP
            LOOP
         ENDIF
         cr=cr+1
         *PR[CR]=PROC_PAY
	 PR[CR]=PUB_PRICE
         medc[cr]=AREA_CODE+SUB_AREACO+PRO_CODE
*         IF LABT_CITO
*            fil1[cr]=AREA_CODE+SUB_AREACO+PRO_CODE+' '+CHR(179)+' '+shrt_descr+' '+' '+spac(1)+SPACE(10)+' '+chr(179)+'  '+STR(proc_x,2)+space(2)+CHR(179)+'  '+TRANS(PR[CR],'###,###')+SPACE(3)+'CITO'
*         ELSE
*           fil1[cr]=AREA_CODE+SUB_AREACO+PRO_CODE+' '+CHR(179)+' '+shrt_descr+' '+' '+spac(1)+SPACE(10)+' '+chr(179)+'  '+STR(proc_x,2)+space(2)+CHR(179)+'  '+TRANS(PR[CR],'###,###')+SPACE(3)+'NON CITO'
           fil1[cr]=AREA_CODE+SUB_AREACO+PRO_CODE+' '+CHR(179)+' '+shrt_descr+' '+' '+spac(1)+SPACE(10)+' '+chr(179)+'  '+STR(proc_x,2)+space(2)+CHR(179)+'  '+TRANS(PR[CR],'###,###')+SPACE(3)
*         ENDIF
         REC[CR]=RECNO()
         skip
      ENDDO
      set colo to BG+/B,W+/N
      pilih=achoice(14,2,19,76,FIL1)
      IF LASTKEY()=13
         set colo to
         medi=medc[pilih]
         RECO=REC[PILIH]
         DPRIC=PR[PILIH]
         LDE=.T.
         GOTO RECO
         IF REC_LOCK(0)
            DELE
         ENDIF
         UNLOCK
         totl=totl-DPRIC
         SELE 6
         USE
         IF NET_USE("&DR&F6",.T.,'6',10)
            PACK
         ENDIF
         DO BOXT WITH 22,46,'TOTAL PAYABLE (Rp.) :'+TRANS(TOTL,'#,###,###'),'GR+','B',.F.,.T.
         do box2 with 22,0,'DELETE OTHER TEST :','YES','NO','gr+','r','W+','N',PL5,.F.,.t.
         SET COLOR TO BG+/B
         @ 14,1 CLEA TO 21,78
         @ 22,0 CLEA TO 24,45
         SET EXCLU OFF
         IF PL5=2
            @ 9,0 CLEA TO 13,79
            ODEL=.T.
         ENDIF
      ELSE
         ODEL=.T.
      ENDIF
   ENDDO
   PL6=0
   IF LDE
      do box2 with 22,0,'REPLACE DELETED TEST :','YES','NO','gr+','r','W+','N',PL6,.F.,.t.
      SET COLOR TO BG+/B
      @ 9,0 CLEA TO 24,79
      IF PL6=1
         COMPLT=.F.
         DO LABLIST
      ELSE
         TERMIN=.T.
      ENDIF
   ELSE
      do box2 with 22,0,'ALL TESTS ENTERED ? :','YES','NO','gr+','r','W+','N',PL6,.F.,.t.
      SET COLOR TO BG+/B
      @ 9,0 CLEA TO 24,79
      IF PL6=1
         TERMIN=.T.
      ELSE
         COMPLT=.F.
         DO LABLIST
      ENDIF
   ENDIF
   RESTSCREEN(00,00,24,80,SVLABT)
ENDDO
sele 6
count to ct FOR VISIT_NBER=STR(VISLA,5)
IF ct=0
   VISLA=VISLA-1
ENDIF
SAVE TO N:VISLAB ALL LIKE VISLA
SET COLO TO W+/B
CLEA
RETURN



*Formatted by: Herman T Ver. 7.1  on December 4, 1995.
